home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_ai / match / match.lsp
Lisp/Scheme  |  1990-04-14  |  2KB  |  74 lines
  1. ;; File: match.lsp
  2. ;; Author: Paul L. Bergstein
  3.  
  4. ;; Common Lisp pattern matching functions
  5.  
  6. ;; Variables in patterns start with '?'
  7. ;; ?* matches anything without binding (wildcard variable)
  8.  
  9. ;;---------------------------------------------------------------
  10. ;; Function MATCH
  11. ;;
  12. ;; Usage: (match <<pattern>> <<data>>) 
  13. ;;
  14. ;; Arguments: 
  15. ;;     pattern -- an s-exp possibly containing variables
  16. ;;     data -- an s-exp which must not contain variables
  17. ;;
  18. ;; Returns:
  19. ;;     If successful -- a list of variable bindings (possibly nil) 
  20. ;;     If the pattern and data don't match -- 'fail
  21. ;;---------------------------------------------------------------
  22.  
  23. (defun match (p d &optional bindings)
  24.     (cond  ((var-p p)
  25.         (match-variable p d bindings))
  26.         ((and (atom p) (atom d))
  27.         (match-atoms p d bindings))
  28.         ((and (listp p) (listp d))
  29.         (match-lists p d bindings))
  30.         (t 'fail)))
  31.  
  32.  
  33.  
  34. (defun var-p (x)
  35.     (cond ((null x) nil)
  36.       ((symbolp x) (char= (char (symbol-name x) 0) #\?))
  37.       (t nil)))
  38.  
  39.  
  40. (defun add-binding (var datum bindings)
  41.     (if (eq '?* var) bindings
  42.     (cons (list var datum) bindings)))
  43.  
  44.  
  45. (defun find-binding (var binding)
  46.     (unless (eq '?* var)
  47.     (assoc var binding)))
  48.  
  49.  
  50. (defun get-value (binding)
  51.     (cadr binding))
  52.  
  53.  
  54. (defun match-atoms (p d bindings)
  55.     (if (eql p d)
  56.     bindings
  57.     'fail))
  58.  
  59.  
  60. (defun match-variable (p d bindings)
  61.     (let ((binding (find-binding p bindings)))
  62.     (if binding
  63.         (match (get-value binding) d bindings)
  64.         (add-binding p d bindings))))
  65.  
  66.  
  67. (defun match-lists (p d bindings)
  68.     (let ((result (match (car p) (car d) bindings)))
  69.     (if (eq 'fail result)
  70.         'fail
  71.         (match (cdr p) (cdr d) result))))
  72.  
  73.  
  74.